COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Benchmark to create once and traverse a Structure
C00007 ENDMK
C⊗;
;;; Benchmark to create once and traverse a Structure
(declare  (fasload struct fas dsk (mac lsp)))

(defstruct node
	   (parents ())
	   (sons ())
	   (sn (snb))
	   (entry1 ())
	   (entry2 ())
	   (entry3 ())
	   (entry4 ())
	   (entry5 ())
	   (entry6 ())
	   (mark ()))

(declare (special sn))
(defun snb () (setq sn (1+ sn)))
(setq sn 0)

(defmacro mod (x n) `(remainder ,x ,n))

(declare (special rand)(fixnum rand))
(setq rand 21.)

(defun seed () (setq rand 21.))

(defun random () (setq rand (mod (* rand 17.) 251.)))

(defun remove (n q)
       (cond ((eq (cdr (car q)) (car q))
	      (prog2 () (caar q) (rplaca q ())))
	     ((= n 0)
	      (prog2 () (caar q)
		     (do ((p (car q) (cdr p)))
			 ((eq (cdr p) (car q))
			  (rplaca q
				  (rplacd p (cdr (car q))))))))
	     (t (do ((n n (1- n))
		     (q (car q) (cdr q))
		     (p (cdr (car q)) (cdr p)))
		    ((= n 0) (prog2 () (car q) (rplacd q p)))))))

(defun select (n q)
       (do ((n n (1- n))
	    (q (car q) (cdr q)))
	   ((= n 0) (car q))))

(defun add (a q)
       (cond ((null q)
	      `(,(let ((x `(,a)))
		      (rplacd x x) x)))
	     ((null (car q))
	      (let ((x `(,a)))
		   (rplacd x x)
		   (rplaca q x)))
	     (t (rplaca q
			(rplacd (car q) `(,a .,(cdr (car q))))))))

(defun create-structure (n)
       (let ((a `(,(make-node))))
	    (do ((m (1- n) (1- m))
		 (p a))
		((= m 0) (setq a `(,(rplacd p a)))
			 (do ((unused a)
			      (used (add (remove 0 a) ()))
			      (x) (y))
			     ((null (car unused))
			      (find-root (select 0 used) n))
			     (setq x (remove (mod (random) n) unused))
			     (setq y (select (mod (random) n) used))
			     (add x used)
			     (setf (sons y) `(,x .,(sons y)))
			     (setf (parents x) `(,y .,(parents x))) ))
		(push (make-node) a))))

(defun find-root (node n)
 (do ((n n (1- n)))
     ((= n 0) node)
     (cond ((null (parents node))
	    (return node))
	   (t (setq node (car (parents node)))))))

(declare (special count marker))

(setq count 0 marker ())

(defun travers (node mark)
       (cond ((eq (mark node) mark) ())
	     (t (setf (mark node) mark)
		(setq count (1+ count))
		(setf (entry1 node) (not (entry1 node)))
		(setf (entry2 node) (not (entry1 node)))
		(setf (entry3 node) (not (entry1 node)))
		(setf (entry4 node) (not (entry1 node)))
		(setf (entry5 node) (not (entry1 node)))
		(setf (entry6 node) (not (entry1 node)))
		(do ((sons (sons node) (cdr sons)))
		    ((null sons) ())
		    (travers (car sons) mark)))))
	


(defun traverse (root)
       (let ((count 0))
	    (travers root (setq marker (not marker)))
	    count))

(include "timer.lsp")
(declare (special root))
(timer init-timit
       (prog2 (setq root (create-structure 100.)) ()))
       
(timer timit
       (do ((i 50. (1- i)))
	   ((= i 0))
	   (traverse root)
	   (traverse root)
	   (traverse root)
	   (traverse root)
	   (traverse root)))